home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / CURR.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  5.6 KB  |  184 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42.  
  43. ;;;; Current State
  44.  
  45. ;;;; Windows
  46. (begin
  47.  
  48. (define-integrable current-window
  49.   (lambda ()
  50.     (current-buffer-window)))
  51.  
  52.  
  53. ;;;; Buffers
  54.  
  55. (define-integrable buffer-list
  56.   (lambda ()
  57.     (bufferset-buffer-list (current-bufferset))))
  58.  
  59. (define-integrable buffer-names
  60.   (lambda ()
  61.     (bufferset-names (current-bufferset))))
  62.  
  63. (define-integrable current-buffer
  64.   (lambda ()
  65.     (window-buffer (current-window))))
  66.  
  67. (define-integrable find-buffer
  68.   (lambda (name)
  69.     (bufferset-find-buffer (current-bufferset) name)))
  70.  
  71. (define-integrable create-buffer
  72.   (lambda (name)
  73.     (bufferset-create-buffer (current-bufferset) name)))
  74.  
  75. (define-integrable find-or-create-buffer
  76.   (lambda (name)
  77.     (bufferset-find-or-create-buffer (current-bufferset) name)))
  78.  
  79. (define-integrable rename-buffer
  80.   (lambda (buffer new-name)
  81.     (bufferset-rename-buffer (current-bufferset) buffer new-name)))
  82.  
  83. (define-integrable current-point
  84.   (lambda ()
  85.     (window-point (current-window))))
  86.  
  87. (define-integrable set-current-point!
  88.   (lambda (mark)
  89.     (set-window-point! (current-window) mark)))
  90.  
  91. (define-integrable current-mark
  92.   (lambda ()
  93.     (buffer-mark (current-buffer))))
  94.  
  95. (define-integrable  set-current-mark!
  96.   (lambda (mark)
  97.     (set-buffer-mark! (current-buffer) mark)))
  98.  
  99. (define-integrable push-current-mark!
  100.   (lambda (mark)
  101.     (push-buffer-mark! (current-buffer) mark)))
  102.  
  103. (define-integrable pop-current-mark!
  104.   (lambda ()
  105.     (pop-buffer-mark! (current-buffer))))
  106.  
  107. (define-integrable current-region
  108.   (lambda ()
  109.     (make-region (current-point) (current-mark))))
  110. )
  111.  
  112. ;;; These have been commented out as are not currently used. However,
  113. ;;; these are useful routines and should not be deleted from this file.
  114.  
  115.  
  116. ;;;(define (kill-buffer buffer)
  117. ;;;  (let ((new-buffer (other-buffer buffer))
  118. ;;;    (current? (eq? buffer (current-buffer)))
  119. ;;;    (windows (buffer-windows buffer)))
  120. ;;;    (if (and (not new-buffer) (not (null? windows)))
  121. ;;;    (error "Buffer to be killed has no replacement" buffer))
  122. ;;;    (bufferset-kill-buffer! (current-bufferset) buffer)
  123. ;;;    (if current? (select-buffer new-buffer))
  124. ;;;    (mapc (lambda (window) (set-window-buffer! window new-buffer))
  125. ;;;      windows)))
  126.  
  127. ;;;(define (with-current-window new-window thunk)
  128. ;;;  (define old-window)
  129. ;;;  (dynamic-wind (lambda ()
  130. ;;;          (set! old-window (current-window))
  131. ;;;          (select-window (set! new-window)))
  132. ;;;        thunk
  133. ;;;        (lambda ()
  134. ;;;          (set! new-window (current-window))
  135. ;;;          (select-window (set! old-window)))))
  136. ;;;
  137. ;;;(define (with-selected-buffer buffer thunk)
  138. ;;;  (define old-buffer)
  139. ;;;  (dynamic-wind (lambda ()
  140. ;;;          (set! old-buffer (current-buffer))
  141. ;;;          (select-buffer-no-record buffer))
  142. ;;;        thunk
  143. ;;;        (lambda ()
  144. ;;;          (set! buffer (current-buffer))
  145. ;;;          (select-buffer-no-record old-buffer))))
  146.  
  147.  
  148. ;;;; Point and Mark
  149.  
  150. ;;;(define (with-current-point new-point thunk)
  151. ;;;  (define old-point)
  152. ;;;  (dynamic-wind (lambda ()
  153. ;;;          (set! old-point (current-point))
  154. ;;;          (set-current-point! new-point))
  155. ;;;        thunk
  156. ;;;        (lambda ()
  157. ;;;          (set! new-point (current-point))
  158. ;;;          (set-current-point! old-point))))
  159.  
  160. (define (buffer-mark buffer)
  161.   (let ((ring (buffer-mark-ring buffer)))
  162.     (if (ring-empty? ring) (editor-error))
  163.     (ring-ref ring 0)))
  164.  
  165. (define (set-buffer-mark! buffer mark)
  166.   (ring-set! (buffer-mark-ring buffer)
  167.          0
  168.          (mark-right-inserting mark)))
  169.  
  170. (define (push-buffer-mark! buffer mark)
  171.   (ring-push! (buffer-mark-ring buffer)
  172.           (mark-right-inserting mark)))
  173.  
  174. (define (pop-buffer-mark! buffer)
  175.   (ring-pop! (buffer-mark-ring buffer)))
  176.  
  177. (define (set-current-region! region)
  178.   (set-current-point! (region-start region))
  179.   (push-current-mark! (region-end region)))
  180.  
  181. (define (set-current-region-reversed! region)
  182.   (push-current-mark! (region-start region))
  183.   (set-current-point! (region-end region)))
  184.